perm filename PT2.F4[MSS,LCS]5 blob sn#194601 filedate 1976-01-01 generic text, type T, neo UTF8
00100		SUBROUTINE PT2
00200		INTEGER VALID
00300		DIMENSION VALID(6),NBAR(36)
00400		DATA QLINE/140.0/,HX/2./,VALID/1,4,8,2,3,-2/,SLSP/11.0/
00500	C  QLINE=BASIC LINE LENGTH, HX=HEIGHT MULTIPLIER, ZL=LN. LNGTH FACTOR.
00600	
00700	C  ADD MORE TO VALID LATER *****
00800		COMMON /SF/KL,RT,KP,STFSZ,NAMX
00900		COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
01000		COMMON/STF/RSTFAC(-3/4),RSTJ2 /IVV/IV(200)
01100		COMMON /POSI/STFF(-3/4),JJ2,JPQ /LLL/L,LL,I,RXQ
01200		1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1)
01300		EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
01400		1,(R8,RQ(6)),(R9,RQ(7)),(LCNT,IV(80)),(NDPY,IV(81))
01500	C  TRNSP'S Bb, F, BBb, A, G, Eb.
01510		NAMQ='AAAAA'
02700	5	FORMAT(F,2I)
02800		IF(RS.NE.'OLD')GO TO 2000
02900		CALL GETFIL('PARTS')
03000		CALL FASTIN(RSTFAC,128)
03100		CALL FASTIN(KPN,JJ2)
03200		CALL FASTIN(Q,JPQ)
03500	2000	TYPE 144
03600	144	FORMAT(' STAFF SIZE, TRANSP.  '$)
03700		ACCEPT 5,RSTJ2,LL
03800		IF(MOD(LL,7).EQ.0)GO TO 140
03900		DO 40 L=1,6
04000	40	IF(LL.EQ.VALID(L))GO TO 140
04100		TYPE 240
04200		GO TO 2000
04300	240	FORMAT(' THIS TRANSP NOT OFFERED')
04400	140	IF(RSTJ2.EQ.0)RSTJ2=.9
04500		L=JJ2-2
04600		TR=LL
04700		IF(LL.NE.0)CALL TRNSP(L,TR)
04800		I=L
04900		KK=1
05000	CC	JJ=0
05100	CC	DO 7 K=1,L
05200	CC	N=PN(K)
05300	CC	IF(Q(N+1).NE.4)GO TO 7
05400	CC	JJ=JJ+1
05500	C  FOUND A BAR LINE
05600	CC	RN(JJ)=Q(N+3)
05700	CC7	CONTINUE
05800	CC	ENDLN=RN(JJ)
05900		ENDLN=ENDL(JJ)
06000	C  FUNCTION ENDL(JJ) (IN FAIL) DOES ALL ABOVE
06100	
06200		NA=1000
06300		N=0
06400		TYPE 90,JJ
06500		RA=0
06600	90	FORMAT(' NUMBER OF BARS PER LINE: TOTAL BAR LINES='I3/)
06700		ZLINE=QLINE
06800	9	KL=0
06900		XLINE=ZLINE
07000		J=0
07100		LL=0
07200		DO 8 K=1,JJ
07300		IF(RN(K).LT.XLINE)GO TO 8
07400		KP=K-KL
07500	C  NUMBER OF BARS, THIS LINE
07600	CC	TYPE 89,KP
07700		KL=K
07800		J=J+1
07900		IF(IV(J).NE.KP)LL=-1
08000		IV(J)=KP
08100		XLINE=RN(K)+ZLINE
08200		IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
08300	8	CONTINUE
08400		IF(LL)TYPE 108,RA,(IV(K),K=1,J)
08500		IF(RT)GO TO 105
08600	108	FORMAT(F6.2,8(3I3,1X))
08700	CC	TYPE 108
08800	CC108	FORMAT(/)
08900	CC89	FORMAT('+',I3,$)
09000		IF(J.GT.NA)GO TO 107
09100		IF(N.EQ.0)GO TO 105
09200	C  SKIP IF FIRST TIME
09300		IF(N.NE.KP)GO TO 106
09400		IF(J.EQ.NA)GO TO 105
09500	106	RT=.05
09600	C SHRINK OR EXPAND?
09700		RA=RA+RT
09800		ZLINE=QLINE*RS/RA
09900	CC	IF(RA.GT.J)GO TO 107
10000		GO TO 9
10050	1107	TYPE 111,KA
10100	107	FORMAT(' CAN''T DO IT!')
10200		TYPE 107
10300	105	TYPE 104,J
10400	104	FORMAT(I4,' LINES - OR TYPE N1, N2 --'$)
10500		KA=0
10600		ACCEPT 5,RA,N,KL
10700	C  TYPE 0,n  TO EXIT WITH n SPACING BETWEEN STAVES (2 IS DEFAULT)
10800		IF(KL.NE.0)GO TO 110
10900	C  FOR SPECIFICATION OF HOW MANY BARS ON EACH LINE
10910	C NO MORE THAN 36 NUMS, INCLUDING 0S (FOR PAGE MARKS)
11000		IF(RA.EQ.0)GO TO 11
11100		IF(ZLINE.EQ.QLINE)RS=J
11200		NA=RA
11300		RT=NA-RA
11400		IF(RT)GO TO 109
11500		RA=RA-.6
11600	C  CHECK THIS ↑↑↑ NUMBER!
11700		IF(N.EQ.0)GO TO 90
11800	109	ZLINE=QLINE*RS/RA
11900		GO TO 9
12000	
12100	111	FORMAT(36I)
12200	110	REREAD 111,NBAR
12300		DO 112 K=36,1,-1
12400		KP=NBAR(K)
12500		KA=KA+KP
12600	112	IF(KP.EQ.0.AND.KA.EQ.0)KL=K
12700		IF(KA.NE.JJ)GO TO 1107
12800	C  MISMATCH!
12900		N=26-2*MOD(KL-1,12)
13000		IF(N.EQ.26)N=0
13010	C  TO SPACE OUT STAVES VERTICALLY
13100	
13200	11	RA=0
13250		JEND=-1
13300		XLINE=ZLINE
13400		CLEF=-99
13500		JSLUR=0
13600		LC=1
13700		SIG=CLEF
13800		HX=2
13900		SP=2.45
13910	C  DEFAULT VERT. SPACE UNITS
14000		IF(N.EQ.0)GO TO 100
14010	C  SPACED OUT DEPENDING ON NUM OF LINES
14100		HX=N
14200		SP=SP+(HX-2.)*.11
14300	100	KL=1
14310		IF(JEND.EQ.0)GO TO 1000
14320	103	FORMAT(' TYPE OUTPUT FILE NAME  ',$)
14328	102	FORMAT(A5)
14336		TYPE 103
14344		ACCEPT 102,NAMX
14352		IF(NAMX.EQ.' ')NAMX=NAMQ
14360		IF(LOOKF(NAMX).GE.0)GO TO 88
14368		TYPE 88,NAMX
14376		ACCEPT 102,L
14384		IF(L.EQ.'N')GO TO 103
14392	88	FORMAT(' WRITE OVER FILE ',A5,'????  '$)
14400	1000	KP=1
14410		JEND=0
14420	C  FLAG FOR PAGE END - WHEN -1
14500		RT=2
14600		J=KK
14700		HGT=HX*2.
14800		LB=0
14900		MTR1=-1
15000	
15100		DO 1 K=KK,I
15200		N=KPN(K)
15300		IF(Q(N+1).NE.4)GO TO 1
15400		IF(KA.EQ.0)GO TO 334
15500		LB=LB+1
15510	C  BAR COUNTER
15600		IF(NBAR(LC).GT.LB)GO TO 1
15700	C FOR SPECIFIED BARS
15800		LC=LC+1
15900		LB=0
15910		IF(NBAR(LC).NE.0)GO TO 335
15920		JEND=-1
15930		LC=LC+1
16000		GO TO 335
16100	334	IF(Q(N+3).LT.XLINE)GO TO 1
16200	C  FOUND LAST BAR LINE.
16300	335	RX=0
16400		MTR1=-1
16500		MTR2=-1
16600		LL=KPN(K+1)
16700	C TO ADD METER AT END OF BAR
16800		RS=Q(LL+1)
16900		IF(RS.LE.4)GO TO 3
17000		IF(RS.EQ.18)MTR1=LL
17100	C WHAT ABOUT REHRSL NUMS, ETC??
17200		LL=KPN(K+2)
17300		RS=Q(LL+1)
17400		IF(RS.LE.4)GO TO 3
17500		IF(RS.EQ.18)MTR2=LL
17600		LL=KPN(K+3)
17700		IF(Q(LL+1).EQ.18)MTR2=LL
17800		IF(MTR1.GT.0)GO TO 3
17900		MTR1=MTR2
18000		MTR2=-1
18100	C IN CASE IT SAW SOMETHING AHEAD OF NEW METER
18200	3	JJ=KP
18300	C PUTS IN STAFF
18400		RS=3.
18500		IF(RT.NE.0)GO TO 331
18600	C NEXT FOR BOTTOM STAFF.  PUTS IN SPACER.
18700		RS=6.
18800	CC	R8=SP
18900	331	CALL STAFF(RS,8.,0,HGT,RSTJ2,0,0,SP)
19000		HGT=HGT-HX
19100		IF(XLINE.EQ.ZLINE)GO TO 33
19200	CC	IF(XLINE.LT.ENDLN)GO TO 6
19210		IF(JEND)GO TO 60
19220	C FOR PREMATURE PAGE END
19300		IF(K.NE.I)GO TO 6
19400		IF(RT.EQ.0)GO TO 6
19500	60	RX=RT
19600		RT=0
19700		CALL STAFF(6.,8.,0,0,0,0,1.,SP)
19800	C  PUTS IN SPACER
19900		RT=RX
20000	6	IF(JSLUR.EQ.0)GO TO 2333
20100		LL=JSLUR
20200		JSLUR=0
20300	1333	CALL STAFF(5.,5.,0,Q(LL),Q(LL+1),SLSP,Q(LL+3),0)
20400	2333	IF(JSL2.EQ.0)GO TO 333
20500		LL=JSL2
20600	C FOR 2ND SLUR AT END OF LINE.
20700		JSL2=0
20800		GO TO 1333
20900	333	IF(CLEF.EQ.-99)GO TO 33
21000	C  ONLY STAFF FOR FIRST LINE AT TOP.
21100		RX=10.*RSTJ2
21200	C  THE SPACER
21300		CALL STAFF(3.,3.,1.,0,CLEF,0,0,0)
21400		IF(SIG.EQ.-99)GO TO 33
21500		RS=4.
21600		R5=SIG
21700		RX=CLEF
21800		IF(R5.LT.50)GO TO 332
21900		RX=IFIX((R5+50.)/100.)
22000		R5=R5-RX*100.
22100	C  CLEF+SIG
22200	332	CALL STAFF(RS,17.,11.0*RSTJ2,0,R5,RX,0,0)
22300		RX=12.*RSTJ2
22400	
22500	33	R4=RA
22600		R5=Q(N+3)
22700		RS=0
22800		R7=RT
22900		R8=RX
23000		R9=200.
23100		LL=0
23200		L=K-J+1
23300		CALL PTMOVE(Q,KPN(J))
23400		RA=R5
23500	31	IF(MTR1)GO TO 231
23600		R=200.0+2.23*RSTJ2
23700		CALL STAFF(Q(MTR1),Q(MTR1+1),R,0,Q(MTR1+5),Q(MTR1+6),0,0)
23800	C  PUTS METER AFTER END OF STAFF
23900		IF(MTR2)GO TO 231
24000		R=200.0+6.7*RSTJ2
24100		CALL STAFF(Q(MTR2),Q(MTR2+1),R,0,Q(MTR2+5),Q(MTR2+6),0,0)
24200	C  PUTS METER AFTER END OF STAFF
24300	231	KB=KL
24400	131	DO 30 NA=KK,K
24500		KWDS(KP)=KB
24600		KP=KP+1
24700		JK=KPN(NA)
24800		R=Q(JK+1)
24900		IF(R.EQ.5)GO TO 135
25000		IF(R.NE.44)GO TO 35
25100	135	RR=Q(JK+6)
25200		IF(RR.LT.Q(JK+3))GO TO 635
25300	C  NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
25400		IF(RR.LT.199.)GO TO 37
25500	C CATCHES END OF SLUR AND VARIOUS LINES
25600	635	IF(R.EQ.5)GO TO 235
25700	C  TO PUT SLUR ON NEXT LINE.
26100	235	IF(JSLUR.NE.0)GO TO 435
26200		JSLUR=JK+4
26300		GO TO 535
26400	435	JSL2=JK+4
26500	C FOR 2ND SLUR
26600	535	RR=201
26610		IF(Q(JK+8).LT.-1)RR=202
26620		Q(JK+6)=RR
26630		IF(R.EQ.5)GO TO 30
26640		GO TO 38
26700	
26800	35	IF(R.NE.2)GO TO 36
26900		IF(Q(JK).LT.6.)GO TO 30
27000	CC	RR=Q(IFIX(PN(NA-1))+3)
27100		RR=RIGHT(NA,-1)
27200		IF(RR.GE.199.)RR=RX
27300	CC	Q(JK+3)=RR-1.6*RSTJ2+(Q(IFIX(PN(NA+1))+3)-RR)/2.
27400		Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1)-RR)/2.
27500	C  FUNCTION 'RIGHT' FINDS RIGHT ITEMS FOR CENTERING.
27600	C CENTERS WHOLE REST
27700		GO TO 30
27800	36	IF(R.NE.3)GO TO 34
27900		RR=Q(JK+5)
28000		IF(Q(JK).LT.3)RR=0
28100		CLEF=AMOD(RR,100.0)
28200		GO TO 30
28300	34	IF(R.NE.17)GO TO 37
28400		SIG=Q(JK+5)
28500		IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
28600	C  CLEF # IN P6 WITH KEY SIGS.
28700	C  NEXT CHANGES CODE NUM BACK TO ORIGINAL
28800	37	IF(R.LT.33)GO TO 30
28900	38	Q(JK+1)=R/11.
29000	30	KB=KPN(NA+1)-KPN(NA)+KB
29100	
29200	CC	DO 31 NA=IFIX(PN(KK)),IFIX(PN(K+1)-1.)
29300	CC	RN(KL)=Q(NA)
29400	CC31	KL=KL+1
29500	CC	KK=K+1
29600		CALL PSHFT(KK,K)
29700		RS=RT
29800		LL='J'
29900		R4=0
30000		R5=200
30100		NA=L
30200		L=KP-JJ
30300		CALL PTMOVE(RN,KWDS(JJ))
30400		DO 47 JJ2=JJ,KP
30500		LL=KWDS(JJ2)
30600		AA=RN(LL+1)
30700		IF(AA.NE.10.AND.AA.NE.16)GO TO 347
30800		DO 147 NN=JJ2+1,KP
30900		MM=KWDS(NN)
31000		IF(RN(MM+1).NE.16)GO TO 147
31100	C  FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
31200		IF(RN(MM).EQ.8)GO TO 47
31300	C  JUMP IF POS. IS ALREADY TAKEN CARE OF.
31400		IF(AA.EQ.10)GO TO 247
31500	C NEXT FOR TEXT FOLLOWING TEXT
31600		IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
31700	C JUMP IF ON DIFF. VERT. PLANE.
31800		AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
31900	C  SETS MINIMUM SPACE.
32000		IF(RN(MM+3).LT.AA)RN(MM+3)=AA
32100		GO TO 47
32200	247	IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
32300	C  CHECKS VERT. POS.
32400		AA=RN(LL+4)+7
32410		IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
32415	C  MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
32420		GO TO 47
32430	147	CONTINUE
32440		GO TO 47
32450	347	IF(AA.NE.5)GO TO 1047
32460	C TO IMPROVE SLUR PARAMETERS
32470		R8=RN(LL+8)
32480		IF(RN(LL).LT.6)R8=0
32490		IF(R8.GT.0)GO TO 47
32500	C  JUMP IF A BRACKET
32510		R=RN(LL+6)
32515	
32520		DO 647 NN=JJ2+1,KP
32530		MM=KWDS(NN)
32540	C  THIS IS TO FIND SLURS AT END OF OLD LINES AND EXTEND THEM
32550		IF(RN(MM+1).NE.4)GO TO 647
32560	C FIND A BAR LINE
32565		IF(RN(MM+3).GT.199.)GO TO 647
32567	C  IGNORE LAST BAR OR LINE.
32570		IF(RN(MM).GT.2)GO TO 647
32575		AA=ABS(RN(MM+3)-R)
32580		IF(AA.GT.1.)GO TO 647
32590		RN(LL+6)=R+4
32600		GO TO 47
32610	647	CONTINUE
32620	
32870		R7=RN(LL+7)
32880		R9=R-RN(LL+3)+(R8+1.)*2.
32890		IF(R9.GT.7)GO TO 47
32900	C  NO WORK NEEDED.  IT'S LONG ENOUGH
32910		IF(RN(LL).GT.5)RN(LL+8)=-1
32920	CC	AA=.5
32930		R=1.
32935		IF(R7.LT.0)R=-R
32940	CC	IF(R7.GT.0)GO TO 547
32950	CC	AA=-AA
32960	C  THE DIP IS DOWN
32970	CC	R=-R
32980	547	RN(LL+4)=RN(LL+4)+R
32990		RN(LL+5)=RN(LL+5)+R
32995	C  WERE +AA ↑↑↑↑↑
33000		RN(LL+7)=R
33100		GO TO 47
33110	1047	IF(AA.NE.6)GO TO 47
33120		IF(RN(LL).LT.7)GO TO 47
33130		IF(RN(LL+9).GT.200.)RN(LL+9)=0
33140	C ********** FIX THIS IN GETPTS, MOVER.  IT SHOULDN'T MOVE P9 ALWAYS.
33310	47	CONTINUE
33325		IF(K.EQ.I)GO TO 2
33340		L=NA
33355		J=K+1
33370	C  SO IT DOESN'T GO THRU ALL DATA
33385		RT=RT-1
33400		XLINE=RA+ZLINE
33500		IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
33600	10	IF(KL.GT.1700.OR.KP.GT.190.OR.RT.OR.JEND)GO TO 2
33700	1	IF(K.EQ.I)GO TO 3
34000	2	KWDS(KP)=KB
34100		J=1
34400		JJ2=KP+1
34500		JPQ=KB
34600	C  WRITES 1 EXTRA WORD
35000		CALL PUTFIL(NAMX)
35100		LCNT=0
35200		NDPY=0
35300		CALL FASTOU(RSTFAC,128)
35400		CALL FASTOU(KWDS,JJ2)
35500		CALL FASTOU(RN,JPQ)
35600		TYPE 101,NAMX
35800		IF(KK.GE.I)CALL EXIT
35900		NAMX=NAMX+2
35950		NAMQ=NAMX
36000		CALL FINFIL
36100		GO TO 100
36110	101	FORMAT(1XA5)
36200		END
36300	
36400	CC	SUBROUTINE STAFF(P0,P1, P3,P4,P5,P6,P7,P8)
36500	CC	COMMON/XRN/RN(2000) /SF/KL,RT,KP,RSTJ2,NAMX
36600	CC	COMMON /PTR/PWDS(250),L,LL,I,IX
36700	CC	PWDS(KP)=KL
36800	CC	KP=KP+1
36900	CC	RN(KL)=P0
37000	CC	RN(KL+1)=P1
37100	CC	RN(KL+2)=RT
37200	CC	RN(KL+3)=P3
37300	CC	RN(KL+4)=P4
37400	CC	RN(KL+5)=P5
37500	CC	IF(P0.LT.4.)GO TO 1
37600	CC	RN(KL+6)=P6
37700	CC	IF(P0.LT.5)GO TO 1
37800	CC	RN(KL+7)=P7
37900	CC	IF(P0.LT.6)GO TO 1
38000	CC	RN(KL+8)=P8
38100	CC1	KL=KL+P0+3.
38200	CC	END
38300	
38400	CC	FUNCTION RIGHT(NA,J)
38500	CC	COMMON /PX/PN(1800) /Q/Q(9000)
38600	CC	K=NA+J
38700	C  J IS EITHER +1 OR -1
38800	CC1	L=PN(K)
38900	CC	IF(Q(L+1).NE.16)GO TO 2
39000	CC	K=K+J
39100	CC	GO TO 1
39200	CC2	RIGHT=Q(L+3)
39300	CC	END